MacGames Sampler/PHT MacGames Bundle.iso/MacSource Folder/Samples from the CD/Pascal/Source□/Talk Source/Talkd ƒ/Talkd.p

Text File | 1992-04-20 | 13.1 KB | 457 lines | [TEXT/PJMM]

{$I-}
program Talkd;

{ This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
{ To compile it you will need the System 7 versions of the Interface files }
{ You may use this source in your own free/shareware projects as long as you acknowledge me }
{ in your About box and documentation files.  You may include it in commercial products }
{ only if I explicitly allow it. }

    uses
        AppleTalk, PPCToolbox, Processes, EPPC, Notification, AppleEvents, MyTrackIdle, MyUtils, {}
        TCPTypes, TCPStuff, UDPStuff, TalkdTypes, Tables, MyLists, MyNotifier, MyPreferences, BaseGlobals;

    const
        min_idle_time = longInt(1) * 60 * 60;  { 1 minute }
        max_notify_display_time = longInt(1) * 60 * 60; { 1 minutes }

    var
        dnrptr: ptr;
        has_AppleEvents: boolean;

    function GotRequiredParams (theAppleEvent: AppleEvent): OSErr;        { <aevt> }
        var
            typeCode: DescType;
            actualSize: Size;
            err: OSErr;
    begin
        err := AEGetAttributePtr(theAppleEvent, keyMissedKeywordAttr, typeWildCard, typeCode, nil, 0, actualSize);    { nil ok: need only function result }
        if err = errAEDescNotFound then        { we got all the required params: all is ok }
            GotRequiredParams := noErr
        else if err = noErr then
            GotRequiredParams := errAEEventNotHandled
        else
            GotRequiredParams := err;
    end; { GotRequiredParams }

    function HandleQUIT (theAppleEvent, reply: AppleEvent; quitp: ptr): OSErr;        { <aevt> }
        var
            oe: OSErr;
            errStr: Str255;
            willQuit: Boolean;                { did the user allow the quit or cancel }
    begin
    { We don't expect any params at all, but check in case the client requires any }
        oe := GotRequiredParams(theAppleEvent);
        quitNow := true;
        if reply.dataHandle <> nil then            { a reply is sought }
            begin
            if oe = noErr then
                errStr := 'OK'
            else
                errStr := 'user cancelled quit';
            oe := AEPutParamPtr(reply, 'errs', 'TEXT', Ptr(@errStr[1]), length(errStr));
        end;
        HandleQUIT := oe;
    end;

    procedure WNE;
        var
            dummy: boolean;
            er: eventRecord;
            oe: OSErr;
    begin
        dummy := WaitNextEvent(everyEvent, er, 15, nil);
        if er.what = kHighLevelEvent then
            if has_AppleEvents then
                oe := AEProcessAppleEvent(er);
        if er.what = keydown then
            quitnow := true;
        TrackIdle;
        NotifyIdle(true);
    end;

    function IsRunning (signature: OSType): boolean;
        var
            process: ProcessSerialNumber;
            info: ProcessInfoRec;
            s: str63;
            fs: FSSpec;
            oe: OSErr;
            gv: longInt;
    begin
        IsRunning := false;
        if (Gestalt(gestaltOSAttr, gv) = noErr) & (BTST(gv, gestaltLaunchControl)) then begin
            process.highLongOfPSN := 0;
            process.lowLongOfPSN := kNoProcess;
            info.processInfoLength := sizeof(ProcessInfoRec);
            info.processName := @s;
            info.processAppSpec := @fs;
            while GetNextProcess(process) = noErr do begin
                if GetProcessInformation(process, info) = noErr then
                    if (info.processType = longInt('APPL')) and (info.processSignature = signature) then begin
                        IsRunning := true;
                        leave;
                    end;
            end;
        end;
    end;

    function AnnounceRequest (var request: ctlMsg; var remote_machine: str255): answers;
{ See if the user is accepting messages. If so, announce that  a talk is requested. }
        var
            sp: stringPtr;
            s: str255;
            oe: OSErr;
            gv: longInt;
            talk_running: boolean;
            secs: longInt;
    begin
        JustGetPrefs(prefs);
        talk_running := IsRunning('tALK');
        if (prefs.allowconnect = AC_Never) | ((prefs.allowconnect = AC_Talk) and not talk_running) then
            AnnounceRequest := A_permission_denied
        else begin
            if not talk_running then begin
{ if Talk is running it will notice by itself in a few secs and notify the user much more sedately }
                GetDateTime(secs);
                IUTimeString(secs, false, s);
                SPrintS5(s, GetGlobalString(alert_pattern), UserToPStr(request.l_name), remote_machine, UserToPStr(request.r_name), s, '');
                sp := stringPtr(NewPtr(Length(s) + 1));
                sp^ := s;
                NotifyH(mark_none, nil, nil, sp, max_notify_display_time);
            end;
            AnnounceRequest := A_success;
        end;
    end;

    procedure AddrToName (ip: longInt; var name: str255);
        var
            hi: hostInfo;
            done: signedByte;
            oe: OSErr;
    begin
        done := 0;
        oe := TCPAddrToName(dnrptr, ip, hi, done);
        if (oe = cacheFault) or (oe = noErr) then begin
            while done = 0 do
                WNE;
            oe := hi.rtnCode;
            if oe = noErr then begin
                SanitizeHostName(hi.rtnHostName);
                name := hi.rtnHostName;
            end;
        end;
        if oe <> noErr then
            TCPAddrToStr(dnrptr, ip, name);
    end;

{    ANNOUNCE - announce to a user that a talk is wanted }
{    LEAVE_INVITE - insert the request into the table }
{    LOOK_UP - look up to see if a request is waiting in }
{          in the table for the local user }
{    DELETE - delete invitation }
{   SCAN - return the id_num'th entry in the table - Added specifically to allow Talk }
{         to scan for waiting connections. WARNING: Returns an extended packet (ie, a }
{         ctlMsg instead of a ctlResponse) }
{  VERIFY_ANNOUNCE - check that the announce request is still there }

    procedure GetSendString (var name: str255);
        var
            f: longInt;
    begin
        f := (TickCount - IdleSince) div 60;
        if f < 180 then
            name := concat(NumToStr(f), GetGlobalString(s_seconds))
        else if f < longInt(180) * 60 then
            name := concat(NumToStr(f div 60), GetGlobalString(s_minutes))
        else if f < 48 * longInt(3600) then
            name := concat(NumToStr(f div 3600), GetGlobalString(s_hours))
        else
            name := concat(NumToStr(f div 86400), GetGlobalString(s_days));
        SPrintS5(name, GetGlobalString(auto_reply_pattern), name, '', '', '', '');
        name := concat(chr($7F), chr($15), chr($13), name);
    end;

    procedure DoAnnounce (var m: ctlMsg; var r: ctlMsg);
        var
            oe: OSErr;
            name: str255;
            ptr: ctlMsgPtr;
            tcpc: TCPConnectionPtr;
            f: longInt;
    begin
        JustGetPrefs(prefs);
        if not ValidUserName(UserToPStr(m.r_name), prefs) then begin
            r.answer := A_not_here;
        end
        else begin
            AddrToName(m.ctl_addr.ip, name);

            ptr := FindRequest(m);
            if ptr = nil then begin
                r.answer := InsertTable(m);
                r.id_num := m.id_num;
                if r.answer = A_success then
                    r.answer := AnnounceRequest(m, name);
                exit(DoAnnounce);
            end
            else if m.id_num > ptr^.id_num then begin
{ This is an explicit re-announce, so update the id_num  }
{ field to avoid duplicates and re-announce the talk. }
{ But we don't handle re-announcing (it screws up Talk anyway) }
{    ptr^.id_num := NewID;}
                r.id_num := ptr^.id_num;
{    r.answer := AnnounceRequest(m, name);}
                r.answer := a_success;
                if prefs.reply_if_idle and (TickCount - IdleSince > min_idle_time) then begin
                    oe := TCPActiveOpen(tcpc, Minimum_TCPBUFFERSIZE, 0, m.addr.ip, m.addr.port, nil);
                    if oe = noErr then begin
                        f := TickCount + 10 * 60; { 10 seconds to connect }
                        while (TickCount < f) and (TCPState(tcpc) <> T_established) do
                            WNE;
                        if TCPState(tcpc) = T_Established then begin
                            GetSendString(name);
                            oe := TCPSend(tcpc, @name[1], length(name));
                        end;
                        oe := TCPClose(tcpc, nil);
                    end;
                end;
            end
            else begin
                r.id_num := ptr^.id_num;
                r.answer := A_success;
            end;
        end;
    end;

    procedure ProcessRequest (var m: ctlMsg; var r: ctlMsg; var extended: boolean);
        var
            ptr: ctlMsgPtr;
    begin
        extended := false;
        r.vers := talk_version;
        r.typ := m.typ;
        r.addr.family := AF_INET;
        r.id_num := 0;
        if m.vers <> talk_version then begin
            r.answer := A_badversion;
            exit(ProcessRequest);
        end;
        m.id_num := m.id_num; { convert byte order }
        m.addr.family := m.addr.family; { convert byte order }
        if m.addr.family <> AF_INET then begin
            r.answer := A_badaddr;
            exit(ProcessRequest);
        end;
        m.ctl_addr.family := m.ctl_addr.family; { convert byte order }
        if m.ctl_addr.family <> AF_INET then begin
            r.answer := A_badctladdr;
            exit(processRequest);
        end;
        m.pid := m.pid; { convert byte order }
{    writeln(m.typ, ', l=', m.l_name, ', r=', m.r_name);}
        case m.typ of
            CT_announce:
                DoAnnounce(m, r);
            CT_leave_invite:  begin
                ptr := FindRequest(m);
                if ptr <> nil then begin
                    r.id_num := ptr^.id_num;
                    r.answer := A_success;
                end
                else begin
                    r.answer := InsertTable(m);
                    r.id_num := m.id_num;
                end;
            end;
            CT_lookup:  begin
                ptr := FindMatch(m);
                if ptr <> nil then begin
                    r.id_num := ptr^.id_num;
                    r.addr := ptr^.addr;
                    r.addr.family := r.addr.family;{ convert to net byte order }
                    r.answer := A_success;
                end
                else
                    r.answer := A_not_here;
            end;
            CT_scan:  begin
                ptr := FindIndexedAnnounce(m.id_num);
                extended := true;
                if ptr <> nil then begin
                    r := ptr^;
                    r.typ := CT_scan;
                    r.answer := A_success;
                end
                else
                    r.answer := A_not_here;
            end;
            CT_VerifyAnnounce:  begin
                m.typ := CT_announce;
                ptr := FindRequest(m);
                if ptr <> nil then begin
                    r.id_num := ptr^.id_num;
                    r.answer := A_success;
                end
                else
                    r.answer := A_not_here;
            end;
            CT_quit:  begin
                quitNow := true;
                r.answer := A_success;
            end;
            CT_delete:  begin
                r.answer := DeleteInvite(m.id_num);
            end;
            otherwise
                r.answer := A_unknown_request;
        end;
    end;

    procedure OToNRequest (datap: ptr; datalen: integer; recport: integer; var request: ctlMsg; var cvt: longInt);
        var
            r: ctlMsg;
            ocr: octlMsg;
            i: integer;
    begin
        if datalen = SizeOf(ctlMsg) then begin
            BlockMove(datap, @request, SizeOf(request));
            cvt := 0  { ntalk }
        end
        else begin
            if datalen = SizeOf(octlMsg) then begin
                BlockMove(datap, @ocr, SizeOf(ocr));
                cvt := 1;
                request.typ := ctlTypes(ord(ocr.data[1]));
                BlockMove(@ocr.data[2], @request.l_name, oname_size);
                for i := oname_size + 1 to name_size do
                    request.l_name[i] := chr(0);
                BlockMove(@ocr.data[11], @request.r_name, oname_size);
                for i := oname_size + 1 to name_size do
                    request.r_name[i] := chr(0);
                request.pid := ocr.pid;
                request.id_num := ocr.id_num;
                request.r_tty := ocr.r_tty;
                request.addr := ocr.addr;
                request.ctl_addr := ocr.ctl_addr;
                if request.addr.family = 0 then
                    request.addr.family := AF_INET;
                if request.ctl_addr.family = 0 then
                    request.ctl_addr.family := AF_INET;
                request.vers := talk_version;
            end
            else begin
                request.vers := -1;
                cvt := -1;
            end;
        end;
    end;

    procedure NToOResponse (cvt: longInt; var response: ctlMsg; extend: boolean; var datalen: integer);
        var
            ocr: octlResponse;
    begin
        if extend then
            datalen := SizeOf(ctlMsg)  { must be ntalk, must be local, must be us! }
        else begin
            case cvt of
                -1:  begin
                    datalen := 0;
                end;
                0:
                    datalen := SizeOf(ctlResponse);
                1:  begin
                    ocr.typ := response.typ;
                    ocr.answer := response.answer;
                    ocr.id_num := response.id_num;
                    ocr.addr := response.addr;
                    BlockMove(@ocr, @response, SizeOf(ocr));
                    datalen := SizeOf(octlResponse);
                end;
            end;
        end;
    end;

    function StackPtr: longInt;
    inline
        $2E8F;

    var
        request: ctlMsg;
        response: ctlMsg;
        extended: boolean;
        udpcn, udpco: UDPConnectionPtr;
        oe: OSErr;
        remoteIP: longInt;
        remoteport: integer;
        datap: ptr;
        datalen: integer;
        s: str255;
        r: rect;
        gv: longInt;
        applLimitP: ^longInt;
        cvt: longInt;
begin
    applLimitP := POINTER($130);
    applLimitP^ := StackPtr - 8000;
{    SetApplLimit(ptr(StackPtr - 8000));}
    MaxApplZone;
    MoreMasters;
    oe := Gestalt(gestaltAppleEventsAttr, gv);
    has_AppleEvents := (oe = noErr) and (gv = 1);
    if has_AppleEvents then
        oe := AEInstallEventHandler(kCoreEventClass, kAEQuitApplication, @HandleQUIT, 0, false);
    InitNotify;
    InitTrackIdle;
    if UDPInit = noErr then begin
        if TCPInit = noErr then begin
            s := '';
            if TCPOpenResolver(s, dnrptr) = noErr then begin
                InitTables;
                if UDPCreate(udpcn, 0, talkd_port) = noErr then begin
                    if UDPCreate(udpco, 0, otalkd_port) = noErr then begin
                        quitNow := false;
                        while not quitNow do begin
                            WNE;
                            while (UDPDatagramsAvailable(udpcn) = 0) and (UDPDatagramsAvailable(udpco) = 0) and not quitNow do
                                WNE;
                            if not quitNow then begin
                                if UDPDatagramsAvailable(udpcn) > 0 then begin { new talk port }
                                    oe := UDPRead(udpcn, 5, remoteIP, remoteport, datap, datalen);
                                    if datalen = SizeOf(ctlMsg) then begin
                                        BlockMove(datap, @request, SizeOf(request));
                                        oe := UDPReturnBuffer(udpcn, datap);
                                        ProcessRequest(request, response, extended);
                                        if extended then
                                            oe := UDPWrite(udpcn, remoteIP, remoteport, @response, SizeOf(response), false)
                                        else
                                            oe := UDPWrite(udpcn, remoteIP, remoteport, @response, SizeOf(ctlResponse), false);
                                    end
                                    else if datalen > 0 then
                                        oe := UDPReturnBuffer(udpco, datap);
                                end
                                else begin { old talk port }
                                    oe := UDPRead(udpco, 5, remoteIP, remoteport, datap, datalen);
                                    if datalen > 0 then begin
                                        OToNRequest(datap, datalen, otalkd_port, request, cvt);
                                        oe := UDPReturnBuffer(udpco, datap);
                                        ProcessRequest(request, response, extended);
                                        NToOResponse(cvt, response, extended, datalen);
                                        oe := UDPWrite(udpco, remoteIP, remoteport, @response, datalen, false)
                                    end;
                                end;
                            end;
                        end;
                        oe := UDPRelease(udpco);
                    end;
                    oe := UDPRelease(udpcn);
                end;
                TCPCloseResolver(dnrptr);
            end;
            TCPFinish;
        end;
        UDPFinish;
    end;
    FinishTrackIdle;
    FinishNotify;
end.